;;; file: handlers.lisp
;;;
;;; Copyright (c) 2010 Steffen Schulz (pepe@virtuallysecure.org)
;;; Copyright (c) 2007-2009 Cyrus Harmon (ch-lisp@bobobeach.com)
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;

(in-package :parseltongue)

(defun markdown* (source)
  (with-output-to-string (str)
    (cl-markdown:markdown 
     (reduce (lambda (x y) (concatenate 'string x y))
	     (with-input-from-string (in source)
	       (loop for line = (read-line in nil :eof)
		  while (not (eq line :eof))
		  collect line)))
     :format :html
     :stream str)))

(defun entry-html (blog entry)
  "Outputs html for a blog entry."
  (with-html
    (:div :class "blog-entry"
          (:div :class "blog-entry-head"
                (:div :class "blog-entry-title"
                      (:h3 (:a :href (blog-entry-url blog entry)
                               (str (blog-entry-title entry)))))
                ;;; TODO: Optional printing of user, date, last-changed
                ;;; TODO: Move text pieces into CSS or replace them there
                ;(let ((user (blog-entry-user entry)))
                ;      (when user
                ;        (htm (:span :class "blog-entry-user"
                ;                    "Posted by " (str user) " on "))))
                (:div :class "blog-entry-date"
                      (str (format-date (blog-entry-time entry)))
                      (unless (< (abs (- (blog-entry-time entry)
                                         (blog-entry-revised-time entry)))
                                 10)
                        ;;(htm ", last updated "
                        ;;     (str (format-date
                        ;;            (blog-entry-revised-time entry)))))))
                        )))
          (:div :class "blog-entry-contents"
                (str (markdown* (blog-entry-contents entry))))
          (let ((tags (blog-entry-tags entry)))
            (when tags
              (htm (:ul :class "blog-entry-tags"
                        (dolist (tag (blog-entry-tags entry))
                          (htm
                            (:li (:a :href (blog-archive-url blog :tag tag) (str tag)))))))))
          (:span :class "blog-entry-nav"
                 (when (http-authenticate blog nil)
                   (htm (:a :href (blog-edit-entry-url blog entry) "[edit]")
                        " "
                        (:a :href (blog-delete-entry-url blog entry) "[delete]")))))))

(defun entry-rss (blog mode entry)
  "Outputs RSS 2.0 for a given blog entry."
  (with-xml
    (:item
      (:title (str (escape-string (blog-entry-title entry))))
      (:link (str (escape-string (blog-absolute-entry-url blog entry))))
      (:description
        (if (and (string= mode "short")
                 (> (length (blog-entry-contents entry)) 200))
          (str (escape-string (markdown* (subseq (blog-entry-contents entry) 0 200))))
          (str (escape-string (markdown* (blog-entry-contents entry))))))
      (:pubDate (str (hunchentoot::rfc-1123-date
                       (blog-entry-time entry))))
      (:guid (str (blog-absolute-entry-url blog entry))))))

(defun blog-feed (blog &key (limit (blog-num-limit blog)))
	"Outputs RSS 2.0 for a complete channel."
  (let ((mode (hunchentoot:get-parameter "mode"))
        (tag  (hunchentoot:get-parameter "tag")))

    (unless (string= mode "full")
      (setf mode "short"))

    (setf (content-type*) "application/rss+xml")
    (with-xml-output-to-string
      (*standard-output*)
      (htm (:rss :version 2.0
                 (:channel
                   (:title (str (blog-title blog)))
                   (:link (str (blog-absolute-root-url blog)))
                   (:description (str (blog-subtitle blog)))
                   (:pubDate (str (hunchentoot::rfc-1123-date)))
                   (loop for entry in
                         (apply #'sorted-blog-entries blog
                                (when tag
                                  `(:tag ,tag)))
                         for i below limit
                         do (entry-rss blog mode entry))))))))

(defun blog-main (blog)
  "Shows $limit last blog entries"
  (with-blog-page
    blog
    (blog-title blog)
    (loop for entry in (sorted-blog-entries blog)
          for i below (blog-num-limit blog)
          do (entry-html blog entry))

    (htm (:div :class "blog-content" :id "archive-navi-older"
               (:a :href (blog-archive-url blog :offset (blog-num-limit blog))
                   "Older entries &gt;&gt;")))))

;;; TODO blog-main is special case of blog-archive!!
(defun blog-main (blog)
	(blog-archive blog))


(defun blog-display (blog)
  "Shows a single blog entry by id"
  (let ((id (parse-integer (hunchentoot:get-parameter "id") :junk-allowed t)))

    (with-blog-page
      blog
      (format nil "~A: display" (blog-title blog))
      (if id
        (let ((entry (get-entry id blog)))
          (if entry
            (entry-html blog entry)
            (with-html
              (:p "Invalid entry."))))
        (with-html
          (:p "No entry ID provided."))))))

(defun blog-archive (blog)
  "Shows $limit last blog entries, starting at $offset, optionally filtered by $tag"
  (let* ((tag  (hunchentoot:get-parameter "tag"))
         (limit (blog-num-limit blog))
         (offset (hunchentoot:get-parameter "offset"))
         (entries (get-blog-entries blog :tag tag)))

    (if offset
      (progn
        (setq offset (or (parse-integer offset :junk-allowed t)
                         0))
        (setq entries (nthcdr offset entries)))
      (setq offset 0))

    (with-blog-page
      blog
      (if tag
        (format nil "~A: ~A" (blog-title blog) tag)
        (format nil "~A: Archive" (blog-title blog)))
      (loop for entry in entries
            for i below limit
            do (entry-html blog entry))

      (when (> offset 0)
        (htm (:div :class "blog-content" :id "archive-navi-newer"
                   (:a :href
                       (apply #'blog-archive-url
                              blog
                              :offset (if (> offset limit)
                                        (- offset limit)
                                        0)
                                    (when tag `(:tag ,tag)))
                       "&lt;&lt; Newer entries"))))

      (when (> (length entries) limit)
        (htm (:div :class "blog-content" :id "archive-navi-older"
                   (:a :href (apply #'blog-archive-url
                                    blog 
                                    :offset (+ offset limit)
                                    (when tag `(:tag ,tag)))
                       "Older entries &gt;&gt;")))))))


;;; TODO: Do not accept entry w/ empty title, tags or content. Instead, show
;;;       error message and re-display input form with provided values.
(defun blog-new (blog)
  "If provided, save fields to new blog entry. Otherwise show input form"
  (let ((user (http-authenticate blog t))
        (tagstring (hunchentoot:post-parameter "tagstring"))
        (content (hunchentoot:post-parameter "content"))
        (title (hunchentoot:post-parameter "title")))

    (with-blog-page
      blog
      (format nil "~A: New Entry" (blog-title blog))
      (if (and (< 0 (length content)) (< 0 (length title)) (< 0 (length tagstring)))
        (entry-html blog (create-blog-entry blog (tagstring-to-taglist tagstring) title content user))
        (with-html
          (when (or (< 0 (length content)) (< 0 (length title)) (< 0 (length tagstring)))
            (htm (:p "Please provide at least title and content.")))
          (:p
            (:form :class "blog-edit" :method :post
                   "Title: "
                   (:input :type :text :name "title" :value (str title))
                   (:br)
                   "Tags: "
                   (:input :type :text :name "tagstring" :value (str tagstring))
                   (:br)
                   (:textarea :name "content" (escape-string (markdown* content)))
                   (:br)
                   (:input :type :submit :value "Submit"))))))))

;;; TODO: Do not accept entry w/ empty title, tags or content. Instead, show
;;;       error message and re-display input form with provided values.
;;; TODO: Merge with blog-new
(defun blog-edit (blog)
  "Like blog-new(!), but saves to entry identified by ID"
  (let* ((user (http-authenticate blog t))
         (tagstring (hunchentoot:post-parameter "tagstring"))
         (content (hunchentoot:post-parameter "content"))
         (title (hunchentoot:post-parameter "title"))
         (id    (parse-integer (hunchentoot:get-parameter "id")))
         (entry (get-entry id blog)))

    (unless entry
      (return-from blog-edit
                   (with-blog-page
                     blog
                     (format nil "~A Edit Entry" (blog-title blog))
                     (with-html
                       (:p (str (format nil "No such entry: ~A" id)))))))

    (if (and (< 0 (length content)) (< 0 (length title)) (< 0 (length tagstring)))
      (progn
        (rem-blog-tag-stats (blog-tag-stats blog) (blog-entry-tags entry))
        (setf (blog-entry-tags entry) (tagstring-to-taglist tagstring))
        (setf (blog-entry-title entry) title)
        (setf (blog-entry-contents entry) content)
        (setf (blog-entry-revised-time entry) (get-universal-time))
        (add-blog-tag-stats (blog-tag-stats blog) (blog-entry-tags entry))
        (store-blog-tag-stats blog)
        (let ((path (blog-entry-storage-path blog)))
          (when path
            (store-blog-entries blog path)))
        (with-blog-page
          blog
          (format nil "~A Edit Entry" (blog-title blog))
          (entry-html blog entry)))
      (with-blog-page
        blog
        (format nil "~A: Edit Entry" (blog-title blog))
        (with-html
          (when (or (< 0 (length content)) (< 0 (length title)) (< 0 (length tagstring)))
            (htm (:p "Please fill out all provided fields.")))
          (:p
            (:form :class "blog-edit" :method :post
                   "Title: "
                   (:input :type :text :name "title" :value (or title
                                                                (blog-entry-title entry)))
                   (:br)
                   "Tags: "
                   (:input :type :text :name "tagstring" :value
                           (str (or tagstring
                                    (taglist-to-tagstring (blog-entry-tags entry)))))
                   (:br)
                   (:textarea :name "content" (escape-string (markdown* (blog-entry-contents entry))))
                   (:br)
                   (:input :type :hidden :name "id" :value (blog-entry-number entry))
                   (:input :type :submit :value "Submit"))))))))

;;; TODO: Delete only on confirmation, otherwise just make private
(defun blog-delete (blog)

  (let* ((user (http-authenticate blog t))
         (id    (parse-integer (hunchentoot:get-parameter "id")))
         (entry (get-entry id blog)))

    (unless entry
      (return-from blog-delete
                   (with-blog-page
                     blog
                     (format nil "~A: error" (blog-title blog))
                     (with-html
                       (:p "Error or deleting entry")))))

    (unless (string= (blog-entry-user entry) user)
      (return-from blog-delete
                   (with-blog-page
                     blog
                     (format nil "~A: error" (blog-title blog))
                     (with-html
                       (:p "Only the author may delete this entry.")))))

    (when (delete-blog-entry blog id)
      (with-blog-page
        blog
        (format nil "~A: delete entry" (blog-title blog))
        (with-html
          (:p "Deleted entry " (str id)))))))

(defun blog-login (blog)
  (let ((user (http-authenticate blog t)))
    (with-blog-page
      blog
      (format nil  "User ~A successfully logged in." user))))

;; TODO: make this a little more userfriendly?
(defun blog-logout (blog)

  ;  (http-authenticate '(("user" . "invalid")) (blog-realm blog)))
  (with-blog-page
    blog
    (format nil "~A: logout" (blog-title blog))
    (with-html
      (:p "Not implemented."))))

(defun init (blog)

  ;; read blog entries
  (unless (read-blog-entries blog)
    ;; TODO: rescan all entries
    (setf (blog-tag-stats blog) (make-hash-table :test 'equal :size 500)))

  ;; read or re-generate tag statistics
  (read-blog-tag-stats blog)

  ;; Rather add prefix-handlers in correct order than adding another dispatcher-function
  ;; Since we push them onto the list, the catch-all function comes first.

  ;; catchall - main
  (pushnew (hunchentoot::create-prefix-dispatcher
             (blog-root-uri blog)
             (lambda () (blog-main blog)))
           hunchentoot::*dispatch-table*)

  ;; feed
  (pushnew (hunchentoot::create-prefix-dispatcher
             (concatenate 'string (blog-root-uri blog) (blog-feed-uri blog))
             (lambda () (blog-feed blog)))
           hunchentoot::*dispatch-table*)

  ;; display
  (pushnew (hunchentoot::create-prefix-dispatcher
             (concatenate 'string (blog-root-uri blog) (blog-display-entry-uri blog))
             (lambda () (blog-display blog)))
           hunchentoot::*dispatch-table*)

  ;; new
  (pushnew (hunchentoot::create-prefix-dispatcher
             (concatenate 'string (blog-root-uri blog) (blog-new-entry-uri blog))
             (lambda () (blog-new blog)))
           hunchentoot::*dispatch-table*)

  ;; edit
  (pushnew (hunchentoot::create-prefix-dispatcher
             (concatenate 'string (blog-root-uri blog) (blog-edit-entry-uri blog))
             (lambda () (blog-edit blog)))
           hunchentoot::*dispatch-table*)

  ;; delete
  (pushnew (hunchentoot::create-prefix-dispatcher
             (concatenate 'string (blog-root-uri blog) (blog-delete-entry-uri blog))
             (lambda () (blog-delete blog)))
           hunchentoot::*dispatch-table*)

  ;; archive
  (pushnew (hunchentoot::create-prefix-dispatcher
             (concatenate 'string (blog-root-uri blog) (blog-archive-uri blog))
             (lambda () (blog-archive blog)))
           hunchentoot::*dispatch-table*)

  ;; login
  (pushnew (hunchentoot::create-prefix-dispatcher
             (concatenate 'string (blog-root-uri blog) (blog-login-uri blog))
             (lambda () (blog-login blog)))
           hunchentoot::*dispatch-table*)

  ;; logout
  (pushnew (hunchentoot::create-prefix-dispatcher
             (concatenate 'string (blog-root-uri blog) (blog-logout-uri blog))
             (lambda () (blog-logout blog)))
           hunchentoot::*dispatch-table*))
